perm filename RECORD[PAT,LMM]1 blob
sn#061075 filedate 1973-09-01 generic text, type T, neo UTF8
(FILECREATED " 1-SEP-73 6:11:10" RECORD)
(LISPXPRINT (QUOTE RECORDVARS)
T)
[RPAQQ RECORDVARS
((FNS RECORD TYPERECORD RECDO COMPOSE0 'CAR 'CDR 'CONS
COMPOSE1 COMPOSE2 COMPOSE3 COMPOSE4 MAKECROPFN
MAKECROPFN1 CLISPLOOKUP LOOK FIELDSIN /PUTDTST)
(PROP CLISPWORD COMPOSE compose)
(PROP MACRO COMPOSE)
(P (/PUT 'compose 'MACRO (GETP 'COMPOSE 'MACRO)))
(P (ADDTOVAR PRETTYTYPELST (CHANGEDRECLST RECORD "records")))
(P (ADDTOVAR CLISPRETTYWORDS compose COMPOSE))
(P (ADDTOVAR CLISPWORDS COMPOSE))
(VARS (CHANGEDRECLST NIL]
(DEFINEQ
(RECORD
[LAMBDA (NAME FIELD)
(COND
[(LISTP NAME)
(COND
((NULL FIELD)
(SETQ FIELD NAME)
(SETQ NAME NIL))
(T (ERROR "Invalid record name" NAME]
((NLISTP FIELD)
(OR (SETQ FIELD (GETP NAME (QUOTE RECORD)))
(ERROR "Invalid record" FIELD T)))
(T (COND
((AND (GETP NAME (QUOTE RECORD))
(NULL DFNFLG))
(LISPXPRINT (CONS NAME (QUOTE (redeclared)))
T)))
(COND
(DWIMFLG (ADDSPELL NAME)))
[COND
(FILEPKGFLG [RPLACA (QUOTE CHANGEDRECLST)
(CONS NAME (CAR (QUOTE CHANGEDRECLST]
LISPXHIST
(UNDOSAVE (LIST (QUOTE /RPLACA)
(CAR (QUOTE CHANGEDRECLST]
(/PUT NAME (QUOTE RECORD)
FIELD)))
(PROG (TEM)
(RECDO (COND
((EQ NAME (CAR FIELD))
(CONS NIL (CDR FIELD)))
(T FIELD))
NIL))
NAME])
(TYPERECORD
[LAMBDA (NAME FIELD)
(RECORD NAME <NAME ! FIELD>)
[/PUTDTST (SETQ FIELD (PACK (LIST NAME "?")))
(LIST (QUOTE LAMBDA)
(QUOTE (IDVAR))
(LIST (QUOTE EQ)
(QUOTE (CAR IDVAR))
(KWOTE NAME]
[/PUT FIELD (QUOTE MACRO)
(LIST (QUOTE (RECORDVAR))
(LIST (QUOTE EQ)
(QUOTE (CAR RECORDVAR))
(KWOTE NAME]
NAME])
(RECDO
[LAMBDA (FORMAT RCROPS)
(COND
((NULL FORMAT)
NIL)
((LISTP FORMAT)
(RECDO (CAR FORMAT)
(CONS (QUOTE A)
RCROPS))
(RECDO (CDR FORMAT)
(CONS (QUOTE D)
RCROPS)))
[(LITATOM FORMAT)
(/PUTDTST FORMAT (MAKECROPFN RCROPS)) (* MUST BE FIXED SO THAT
WILL COMPILE PROPERLY)
(/PUT FORMAT (QUOTE RCROPS)
(CONS NAME RCROPS))
[/PUT FORMAT (QUOTE ACCESSFN)
(CONS FORMAT (SETQ TEM (PACK (LIST "RPLAC." FORMAT]
(/PUT TEM (QUOTE ACCESSFN)
FORMAT)
(/PUT TEM (QUOTE MACRO)
(LIST (QUOTE X)
(LIST (QUOTE LOOK)
[KWOTE (PACK (LIST (QUOTE RPLAC)
(CAR RCROPS]
[LIST (QUOTE DSUBST)
(QUOTE (CAR X))
(QUOTE (QUOTE RECORDFIELDVAR))
(KWOTE (MAKECROPFN1 (CDR RCROPS]
(QUOTE (CADR X]
(T (ERROR "Invalid record field" FORMAT])
(COMPOSE0
[LAMBDA (X)
(* Constructs a composition of FIELD using things
from L -
First L must be split up into things in field)
(PROG ((L (CDR X))
(FIELDS (OR (GETP (CAR X)
(QUOTE RECORD))
(ERROR X:1 "not a record")))
VAR DEF FROMVAR RECFIELDS !RECORDFLG)
[SETQ !RECORDFLG (COND
((EQ (CAR FIELDS)
(CAR X))
(CAR X]
(SETQ RECFIELDS (FIELDSIN FIELDS))
[COND
((MISSPELLED? (CAR L)
70
(QUOTE (FROM))
T L NIL)
(SETQ FROMFLG (CADR L))
(SETQ L (CDDR L]
(DWIMIFY1B L X L T)
(for X in L do (SELECTQ (CAR X)
((SETQ SETQQ)
(OR (MISSPELLED? (CADR X)
70 RECFIELDS T
(CDR X)
NIL)
(ERROR "Bad field name"
(CADR X)
T)))
(ERROR "form not fieldname←value in"
(CONS (QUOTE compose)
X)
T)))
[SETQ DEF
(COMPOSE1 FIELDS
(AND FROMVAR
(if LISTP FROMVAR
then VAR←'COMPOSEVAR
elseif !RECORDFLG
then 'CDR FROMVAR
else FROMVAR]
[COND
(VAR (SETQ DEF (LIST (LIST (QUOTE LAMBDA)
(LIST VAR)
DEF)
(COND
(!RECORDFLG ('CDR FROMVAR))
(T FROMVAR]
(RETURN (COND
(!RECORDFLG ('CONS (KWOTE !RECORDFLG)
DEF))
(T DEF])
('CAR
[LAMBDA (X)
(AND X (PROG [(TEM (FASSOC (CAR X)
(QUOTE ((CAR . CAAR)
(CDR . CADR)
(CAAR . CAAAR)
(CADR . CAADR)
(CDAR . CADAR)
(CDDR . CADDR)
(CAAAR . CAAAAR)
(CAADR . CAAADR)
(CADAR . CAADAR)
(CADDR . CAADDR)
(CDAAR . CADAAR)
(CDADR . CADADR)
(CDDAR . CADDAR)
(CDDDR . CADDDR]
(COND
(TEM (LIST (CDR TEM)
(CADR X)))
(T (LIST (QUOTE CAR)
X])
('CDR
[LAMBDA (X)
(AND X (PROG [(TEM (FASSOC (CAR X)
(QUOTE ((CAR . CDAR)
(CDR . CDDR)
(CAAR . CDAAR)
(CADR . CDADR)
(CDAR . CDDAR)
(CDDR . CDDDR)
(CAAAR . CDAAAR)
(CAADR . CDAADR)
(CADAR . CDADAR)
(CADDR . CDADDR)
(CDAAR . CDDAAR)
(CDADR . CDDADR)
(CDDAR . CDDDAR)
(CDDDR . CDDDDR]
(COND
(TEM (LIST (CDR TEM)
(CADR X)))
(T (LIST (QUOTE CDR)
X])
('CONS
[LAMBDA (CARPART CDRPART)
(COND
[(OR (EQ (CAR CDRPART)
(QUOTE LIST))
(NOT (CAR CDRPART)))
(CONS (QUOTE LIST)
(CONS CARPART (CDR CDRPART]
(T (LIST (QUOTE CONS)
CARPART CDRPART])
(COMPOSE1
[LAMBDA (FIELD DEF)
(PROG (K)
(COND
((SETQ K (COMPOSE2 FIELD DEF))
(CAR K))
(FROMVAR DEF)
(T (COMPOSE4 FIELD])
(COMPOSE2
[LAMBDA (FIELD DEF)
(* Constructs the composition of FIELD , returning
NIL if none of the fields in FIELD are mentioned in
L -
and <consexpression> otherwise)
(COND
((NULL FIELD)
NIL)
[(ATOM FIELD)
(for X in L when (EQ (CADR X)
FIELD)
do (RETURN (COND
[(EQ (CAR X)
(QUOTE SETQQ))
(LIST (KWOTE (CADDR X]
(T (CDDR X]
(T (PROG [(KD (COMPOSE2 (CDR FIELD)
('CDR DEF)))
(KA (COMPOSE2 (CAR FIELD)
('CAR DEF]
(COND
((AND (NULL KA)
(NULL KD))
(RETURN NIL)))
(RETURN (LIST ('CONS [COND
(KA (CAR KA))
(FROMVAR ('CAR DEF))
(T (COMPOSE4 (CAR FIELD]
(COND
(KD (CAR KD))
(FROMVAR ('CDR DEF))
(T (COMPOSE4 (CDR FIELD])
(COMPOSE3
[LAMBDA (L)
(* Creates the defaalt value for field -- if there
was a FROM then it's just the from thing , otherwise
its a CONS of the individual fields)
(COND
(FROMVAR DEF)
(T (COMPOSE4 FIELD])
(COMPOSE4
[LAMBDA (FIELD)
(COND
((NULL FIELD)
NIL)
[(ATOM FIELD)
([LAMBDA (X)
(COND
(X (KWOTE X]
(GETP FIELD (QUOTE RECDEFAULT]
(T ('CONS (COMPOSE4 (CAR FIELD))
(COMPOSE4 (CDR FIELD])
(MAKECROPFN
[LAMBDA (RCROPS)
(OR [FGETD (PACK (CONS (QUOTE C)
(APPEND RCROPS (LIST (QUOTE R]
(LIST (QUOTE LAMBDA)
(QUOTE (RECORDFIELDVAR))
(MAKECROPFN1 RCROPS])
(MAKECROPFN1
[LAMBDA (RCROPS)
(COND
((NULL RCROPS)
(QUOTE RECORDFIELDVAR))
((NULL (CDDDDR RCROPS))
(LIST [PACK (CONS (QUOTE C)
(APPEND RCROPS (QUOTE (R]
(QUOTE RECORDFIELDVAR)))
(T (LIST (PACK (LIST (QUOTE C)
(CAR RCROPS)
(CADR RCROPS)
(CADDR RCROPS)
(CADDDR RCROPS)
(QUOTE R)))
(MAKECROPFN1 (CDDDDR RCROPS])
(CLISPLOOKUP
[LAMBDA (FN VAR1 VAR2 LISPFN)
(* In most cases, it is not necessary to do a full
lookup. This is q uick an dirty check inside of the
block to avoid calling CLISPLOOKUP0 It will work
whenever there are no declarations.
Only difference between this and CLISPIFYLOOKUP is
that is that we already have performed
(GETP FN 'LISPFN))
(PROG (CLASS TEM)
(RETURN (COND
([OR (AND (SETQ CLASS (GETP FN (QUOTE CLISPCLASS)))
(EQ (CAR (SETQ TEM (CADDR EXPR)))
(QUOTE *))
(EQ (CADR TEM)
(QUOTE DECLARATIONS:))
(SETQ TEM (CDDDR TEM)))
(AND (EQ (CAR TEM)
(QUOTE CLISP:))
(SETQ TEM (CLISPDEC0 TEM FAULTFN]
(* must do full lookup.)
(CLISPLOOKUP0 FN VAR1 VAR2 TEM CLASS))
(T (OR LISPFN FN])
(LOOK
[LAMBDA (FN ARG1 ARG2)
(LIST (CLISPLOOKUP FN ARG1 ARG2 (GETP FN (QUOTE LISPFN)))
ARG1 ARG2])
(FIELDSIN
[LAMBDA (X)
(COND
((NULL X)
NIL)
((NLISTP X)
(LIST X))
(T (NCONC (FIELDSIN (CAR X))
(FIELDSIN (CDR X])
(/PUTDTST
[LAMBDA (ATM DEF)
[COND
((FGETD ATM)
(VIRGINFN ATM T)
(COND
((NULL DFNFLG)
(LISPXPRINT (CONS FORMAT (QUOTE (redefined)))
T)
(SAVEDEF ATM]
(COND
(DWIMFLG (ADDSPELL ATM)))
(/PUTD ATM DEF])
)
(DEFLIST(QUOTE(
(COMPOSE (T . compose))
(compose (T . compose))
))(QUOTE CLISPWORD))
(DEFLIST(QUOTE(
(COMPOSE (X (COMPOSE0 X)))
))(QUOTE MACRO))
(/PUT 'compose 'MACRO (GETP 'COMPOSE 'MACRO))
(ADDTOVAR PRETTYTYPELST (CHANGEDRECLST RECORD "records"))
(ADDTOVAR CLISPRETTYWORDS compose COMPOSE)
(ADDTOVAR CLISPWORDS COMPOSE)
(RPAQ CHANGEDRECLST NIL)
STOP